home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
vmmngr.zip
/
VMM.IN2
< prev
next >
Wrap
Text File
|
1990-07-16
|
23KB
|
705 lines
{*********************************************************}
{* VMM.IN2 1.00 *}
{*********************************************************}
constructor Dynarray.Init(MaxElements, ElementSize, Incr : Word);
{-Called when a dynamic array is created}
begin
if (not Root.init) then
Fail;
if (ElementSize = 0)
or (Incr = 0)
or (Incr > MaxElements)
or (MaxElements = 0)
or (LongInt(ElementSize)*Incr > MaxHeapAlloc)
or (LongInt(MaxElements)*ElementSize > MaxHeapAlloc) then begin
Done;
InitStatus := epFatal+ecBadParam;
Fail;
end;
daBase := nil;
daElemSize := ElementSize;
daArraySize:= 0;
daInc := Incr;
daMaxIndex := MaxElements-1;
daValidElems := 0;
daStatus := 0;
end;
destructor DynArray.Done;
{-Free memory occupied by the array}
begin
Clear;
Root.Done;
end;
function DynArray.GetStatus : Word;
{-Return and reset array status}
begin
GetStatus := daStatus;
daStatus := 0;
end;
function DynArray.PeekStatus : Word;
{-Return array status}
begin
PeekStatus := daStatus;
end;
procedure DynArray.Error(Code : Word);
{-Assign error code}
begin
daStatus := Code;
end;
procedure DynArray.SetElem(Index : Word; var Elem);
{-Set an array element to a given value; Increase size if necessary}
var
P : Pointer;
NewSize : Word;
NeededElems : Word;
begin
if Index > daMaxIndex then begin
Error(epFatal+ecBadParam);
Exit;
end;
NeededElems := Succ(Index);
if NeededElems > daArraySize div daElemSize then begin
{The memory space allocated to the array must be increased}
if (NeededElems mod daInc <> 0) or (Index = 0) then
NeededElems := Succ(NeededElems div daInc) * daInc;
if NeededElems > Succ(daMaxIndex) then
NeededElems := Succ(daMaxIndex); {No superfluous allocation}
NewSize := NeededElems*daElemSize;
if UserGetMem(P, NewSize) then begin
FillChar(AddWordToPtr(P, daArraySize)^, NewSize-daArraySize, 0);
Move(daBase^, P^, daArraySize); {Data transfer}
UserFreeMem(daBase, daArraySize); {The bigger daIncr, the lesser}
daArraySize := NewSize; { the heap will be fragmented}
daBase := P;
end
else begin
Error(epFatal+ecOutOfMemory);
Exit;
end;
end;
if Succ(Index) > daValidElems then
daValidElems := Succ(Index);
{Now stores the element data into the array}
Move(Elem, AddWordToPtr(daBase, daElemSize*Index)^, daElemSize);
end;
procedure DynArray.GetElem(Index : Word; var Elem);
{-Return the indexth element}
begin
if Succ(LongInt(Index)) > daValidElems then
Error(epFatal+ecBadParam)
else
Move(AddWordToPtr(daBase, daElemSize*Index)^, Elem, daElemSize);
end;
function DynArray.GetElemSize : Word;
{-Return size of an element}
begin
GetElemSize := daElemSize;
end;
function DynArray.GetArraySize : Word;
{-Return actual size of array}
begin
GetArraySize := daArraySize;
end;
function DynArray.GetMaxIndex : Word;
{-Return maximum index allowed}
begin
GetMaxIndex := daMaxIndex;
end;
function DynArray.GetValidElems : Word;
{-Return number of valid elements}
begin
GetValidElems := daValidElems;
end;
procedure DynArray.Shrink(ElemNb : Word);
{-Shrink array size to ElemNb elements and discard exceeding elements}
var
P : pointer;
NewSize : Word;
SaveElemNb : Word;
begin
if ElemNb = 0 then begin
Clear;
Exit;
end;
if ElemNb >= daArraySize div daElemSize then
Exit;
SaveElemNb := ElemNb;
if ElemNb mod daInc <> 0 then
ElemNb := Succ(ElemNb div daInc) * daInc;
NewSize := ElemNb*daElemSize;
if NewSize < daArraySize then
{Need to reallocate a smaller buffer}
if UserGetMem(P, NewSize) then begin
Move(daBase^, P^, NewSize); {No need to fill with nulls since}
UserFreeMem(daBase, daArraySize); { it's a smaller block}
daArraySize := NewSize;
daBase := P;
end
else begin
Error(epFatal+ecOutOfMemory);
Exit;
end;
{No reallocation - just need to adjust daValidElems}
if daValidElems > SaveElemNb then
daValidElems := SaveElemNb;
end;
procedure DynArray.Clear;
{-Reset array to minimum size and discard all elements}
begin
UserFreeMem(daBase, daArraySize);
daArraySize := 0;
daValidElems := 0;
daStatus := 0;
end;
constructor DynArray.Load(var S : IdStream);
{-Load a dynamic array from a stream}
begin
daBase := nil;
if not Root.Init then
Fail;
{Read characteristics of dynamic array}
S.ReadRange(daElemSize, daBase);
if S.PeekStatus <> 0 then begin
Done;
Fail;
end;
{Allocates memory to store array data}
if not UserGetMem(daBase, daArraySize) then begin
Done;
InitStatus := epFatal+ecOutOfMemory;
Fail;
end;
{Now read array data}
S.Read(daBase^, daArraySize);
if S.PeekStatus <> 0 then begin
Done;
Fail;
end;
end;
procedure DynArray.Store(var S : IdStream);
{-Store a dynamic array in a stream}
begin
{Write characteristics of dynamic array}
{Only daBase is not stored}
S.WriteRange(daElemSize, daBase);
{Write array data}
S.Write(daBase^, daArraySize);
end;
procedure DynArrayStream(SPtr : IdStreamPtr);
{-Register all types needed for streams containing DynArrays}
begin
SPtr^.RegisterType(otDynArray, veDynArray, TypeOf(DynArray),
@DynArray.Store, @DynArray.Load);
end;
{---------------------------------------------------------------------}
procedure VmmStaticQueue.Remove(var Element);
{-Remove first element found equal to Element from the queue}
{
This procedure is needed to maintain the LRU queue. The very nature of
the LRU algorithm is to push into the queue a VMM handle each time it is
dereferenced. So, if we make sure that this handle is deleted before
pushing it into the queue, when we lock it or when we free it, we'll also
be sure that the "Least Recently Used" handle will be the first one
to be popped out from the queue.
Since we are sure that the elements processed by a VmmStaticQueue are
always handles (i.e. WORDs) the CompElem function is not really needed
because we should only compare WORDs. Though, the CompElem function
allows the VmmStaticQueue to be used for other purposes.
}
var
Ptr : Word;
Found : Boolean;
begin
if sqTail > sqHead then begin
{There is no wrap-around in the queue}
Ptr := sqHead;
Found := false;
while not Found and (Ptr < sqTail) do begin
Inc(Ptr, sqElSize);
Found := CompElem(Element, sqBase^[Ptr], sqElSize);
end;
if Found then begin
{Remove element}
Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], sqTail-Ptr);
sqDec(sqTail);
end;
end
else if not IsEmpty then begin
{First search from Head to end of buffer}
Ptr := sqHead;
Found := false;
while not Found and (Ptr < sqSize) do begin
Inc(Ptr, sqElSize);
Found := CompElem(Element, sqBase^[Ptr], sqElSize);
end;
if not Found then begin
{Search from beginning of buffer to Tail}
Ptr := 0;
repeat
Found := CompElem(Element, sqBase^[Ptr], sqElSize);
Inc(Ptr, sqElSize);
until Found or (Ptr >= sqTail);
Dec(Ptr, sqElSize);
end;
if Found then begin
{Remove element}
if (Ptr > sqHead) then begin
{A little bit trickier in that case - circular move}
Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], (sqSize-Ptr-sqElSize));
Move(sqBase^, sqBase^[sqSize-sqElSize], sqElSize);
Move(sqBase^[sqElSize], sqBase^, sqTail);
end
else
Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], sqTail-Ptr);
sqDec(sqTail);
end;
end;
{If not found does nothing}
end;
function VmmStaticQueue.IsEmpty : Boolean;
{-Return true if queue is empty}
begin
IsEmpty := sqHead = sqTail;
end;
{---------------------------------------------------------------------}
constructor AbstractFreeList.Init(MaxElements, Incr : Word);
{-Initialize a dynamic array of FreeRecords}
begin
if not DynArray.Init(MaxElements, SizeOf(FreeRecord), Incr) then
Fail;
end;
function AbstractFreeList.GetFreeEntrySize(Index : Word) : LongInt;
{-Return size of a free block}
begin
{This virtual method must be overridden by descendants}
Abstract;
end;
function AbstractFreeList.SizeToEndPtr(OrgPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given OrgPtr and block size, return new entry's EndPtr}
begin
{This virtual method must be overridden by descendants}
Abstract;
end;
function AbstractFreeList.SizeToOrgPtr(EndPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
begin
{This virtual method must be overridden by descendants}
Abstract;
end;
function AbstractFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
{-Return true if pointers can be merged to form a new freelist entry}
begin
{This virtual method must be overridden by descendants}
Abstract;
end;
function AbstractFreeList.GetFreeEntry(BlkSize : Word) : Pointer;
{-Search free list for a free block, return a pointer to it}
var
CurIndex : Word;
CurEntSize : LongInt;
CurFreeRec : FreeRecord;
begin
if daValidElems = 0 then begin
GetFreeEntry := nil;
Exit;
end
else begin
for CurIndex := 0 to Pred(daValidElems) do begin
{Scan free list for a block that is big enough}
GetElem(CurIndex, CurFreeRec);
if GetStatus <> 0 then begin
GetFreeEntry := nil;
Exit;
end;
CurEntSize := GetFreeEntrySize(CurIndex);
if CurEntSize > BlkSize then begin
{bigger than needed - shrink size of block}
GetFreeEntry := CurFreeRec.OrgPtr;
CurFreeRec.OrgPtr := SizeToOrgPtr(CurFreeRec.EndPtr, CurEntSize-BlkSize);
SetElem(CurIndex, CurFreeRec);
if (GetStatus = 0) and Sort then;
{Sort free list to make sure GetFreeEntry will always choose the}
{ smallest possible block - this will prevent fragmentation}
Exit;
end
else if CurEntSize = BlkSize then begin {Exact match}
GetFreeEntry := CurFreeRec.OrgPtr;
{Delete used entry}
RemoveFreeEntry(CurIndex);
if (GetStatus = 0) and Sort then;
Exit;
end;
end;
{We didn't find a free entry which size is >= BlkSize}
GetFreeEntry := nil;
end;
end;
function AbstractFreeList.AddFreeEntry(ThisOrgP : Pointer;
BlkSize : LongInt) : LongInt;
{-Insert a new free block in the FreeList or merge it with an }
{ existing one - return size of entry in FreeList}
var
SaveIndex : Word;
CurIndex : Word;
CurFreeRec : FreeRecord;
ThisEndP : Pointer;
FoundOne : Boolean;
FoundTwo : Boolean;
Found : Boolean;
Pass : 1..2;
label
AddIt;
begin
ThisEndP := SizeToEndPtr(ThisOrgP, BlkSize);
FoundOne := false;
FoundTwo := false;
if daValidElems = 0 then {Nothing to search for}
Goto AddIt;
for Pass := 1 to 2 do begin
{All blocks combinations should be found in two passes}
CurIndex := 0;
Found := false;
while (CurIndex <= Pred(daValidElems)) and not Found do begin
{search for a free list entry to combine with}
GetElem(CurIndex, CurFreeRec);
{does the EndPtr of our entry match the start of the current one ?}
if PtrIsEqual(ThisEndP, CurFreeRec.OrgPtr) then begin
CurFreeRec.OrgPtr := ThisOrgP;
Found := true;
{Save index for freelist update if second match found}
if Pass = 1 then begin
ThisEndP := CurFreeRec.EndPtr; {save it for next loop}
SaveIndex := CurIndex;
FoundOne := true;
end
else
{Second match found}
FoundTwo := true;
end
{does the OrgPtr of our entry match the ind of the current one ?}
else if PtrIsEqual(ThisOrgP, CurFreeRec.EndPtr) then begin
CurFreeRec.EndPtr := ThisEndP;
Found := true;
if Pass = 1 then begin
ThisOrgP := CurFreeRec.OrgPtr; {save it for next loop}
SaveIndex := CurIndex;
FoundOne := true;
end
else
FoundTwo := true;
end;
{go to next entry in the freelist or...}
if not Found then
Inc(CurIndex)
else begin
{...update entry in freeList}
SetElem(CurIndex, CurFreeRec);
if GetStatus <> 0 then
AddFreeEntry := 0
else
AddFreeEntry := GetFreeEntrySize(CurIndex);
end;
end;
end;
AddIt:
if FoundTwo then
{We found two blocks to combine with ours - the first one has to be deleted}
RemoveFreeEntry(SaveIndex)
else if not FoundOne then begin
{No block combination was possible - add new entry to freelist}
CurFreeRec.OrgPtr := ThisOrgP;
CurFreeRec.EndPtr := SizeToEndPtr(ThisOrgP, BlkSize);
SetElem(daValidElems, CurFreeRec);
AddFreeEntry := GetFreeEntrySize(Pred(daValidElems));
end;
if not ((GetStatus = 0) and Sort) then
AddFreeEntry := 0;
{Sort free list to make sure GetFreeEntry will always choose the}
{ smallest possible block - this will prevent fragmentation}
end;
procedure AbstractFreeList.RemoveFreeEntry(Index : Word);
{-Remove entry from the list and shrink list size}
var
LastIndex : Word;
F : FreeRecord;
begin
if (daValidElems = 0) or (Index > daValidElems) then begin
Error(epFatal+ecBadParam);
Exit;
end;
LastIndex := Pred(daValidElems);
{Move last entry...}
GetElem(LastIndex, F);
{...to the entry to be deleted}
SetElem(Index, F);
{and shrink freelist by one element}
Shrink(LastIndex);
end;
function AbstractFreeList.MaxFree : Longint;
{-Return size of largest free entry}
begin
{Since the free list is always sorted in block size order}
{ the largest block available is always the last one}
if daValidElems > 0 then
MaxFree := GetFreeEntrySize(Pred(daValidElems))
else
MaxFree := 0;
end;
procedure AbstractFreeList.QuickSort(L, R : Word);
{-Actual sort procedure called by Sort}
const
StackToKeep = 512;
var
i, j, p : LongInt;
Ei, Ej : FreeRecord;
begin
if SPtr > StackToKeep then begin {Keep StackToKeep bytes free on stack}
i := L; {Each recursion uses approximately 50 bytes}
j := R;
p := (i+j) div 2;
repeat
while GetFreeEntrySize(i) < GetFreeEntrySize(p) do
Inc(i);
while GetFreeEntrySize(p) < GetFreeEntrySize(j) do
Dec(j);
if i <= j then begin {Swap elements}
GetElem(i, Ei);
GetElem(j, Ej);
SetElem(i, Ej);
SetELem(j, Ei);
Inc(i);
Dec(j);
end;
until i > j;
if L < j then
QuickSort(L, j); {Recursive call with new boundaries}
IF i < R then
QuickSort(i, R);
end
else
Error(epNonFatal+ecOutOfMemory);
end;
function AbstractFreeList.Sort : boolean;
{-Sort the free list in block size order}
var
Count : Word;
const
MaxCount = 3;
begin
Count := 0;
if daValidElems > 1 then
repeat
QuickSort(0, Pred(daValidElems));
Inc(Count);
until (PeekStatus = 0) or (Count = MaxCount);
Sort := GetStatus = 0;
{
Some explanations needed here. It's very important for the VMM that
the freelist sort succeeds. If not, MaxFree will not return the right
value and fragmentation will begin. The only reason for Sort to fail
is that we could run out of stack space. In that case the array remains
partially sorted. However, the number of recursions needed for a QuickSort
depends heavily on the initial order of items in the array. So, a
second (or a third) try on the partially sorted array may (will likely)
succeed. Moreover, freelists are sorted very often. Hence, the required
number of recursions will be very low.
In most cases freelists will not be very big. So the SORT method will
succeed anyway. Some experiments showed that even very big arrays
can be sorted in 3 passes. In the very rare situations where 3 passes
are not enough, you may want to increase MaxCount to allow more passes.
}
end;
{---------------------------------------------------------------------}
function VmmRamFreeList.GetFreeEntrySize(Index : Word) : LongInt;
{-Return size of a free block}
var
F : FreeRecord;
begin
GetElem(Index, F);
if GetStatus = 0 then
with F do
GetFreeEntrySize := PtrToLong(EndPtr) - PtrToLong(OrgPtr)
else
GetFreeEntrySize := 0;
end;
function VmmRamFreeList.SizeToEndPtr(OrgPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given OrgPtr and block size, return new entry's EndPtr}
begin
{Assume BlkSize validity}
SizeToEndPtr :=AddLongToPtr(OrgPtr, BlkSize);
end;
function VmmRamFreeList.SizeToOrgPtr(EndPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given EndPtr and block size, return new entry's OrgPtr}
begin
{Assume BlkSize validity}
SizeToOrgPtr := LongToPtr(PtrToLong(EndPtr) - BlkSize);
end;
function VmmRamFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
{-Return true if pointers can be merged to form a new freelist entry}
begin
PtrIsEqual := PtrToLong(P1) = PtrToLong(P2);
end;
{---------------------------------------------------------------------}
function VmmEmsFreeList.AddFreeEntry(ThisOrgP : Pointer;
BlkSize : Word) : LongInt;
{Override generic AddFreeEntry method because Ems need special handling}
{ This method will deallocate an Ems frame when it is empty}
var
F : FreeRecord;
Found : Boolean;
CurIndex : Word;
begin
{Use generic method and if entire Ems page frame is free, deallocate handle}
if AbstractFreeList.AddFreeEntry(ThisOrgP, BlkSize) = MaxEmsBlock then begin
{Because the freelist has been sorted in block order size the new}
{ entry is now necessarily the last one because it has the maximum}
{ size - So we only have to free the handle of the last entry and}
{ to remove it from the list}
GetElem(Pred(daValidElems), F);
if not DeAllocateEmsHandle(VmmPtrRec(F.OrgPtr).Seg) then
Error(epNonFatal+ecCantFreeEms)
else begin
{Remove entry from freelist - we remove the last one, no need to sort}
RemoveFreeEntry(Pred(daValidElems));
if PeekStatus <> 0 then
AddFreeEntry := 0;
end;
end;
end;
function VmmEmsFreeList.GetFreeEntrySize(Index : Word) : LongInt;
{-Return size of a free block}
var
F : FreeRecord;
begin
GetElem(Index, F);
if GetStatus = 0 then
with F do
GetFreeEntrySize := VmmPtrRec(EndPtr).Ofs - VmmPtrRec(OrgPtr).Ofs
else
GetFreeEntrySize := 0;
{The segment part is assumed to be the same for EndPtr and OrgPtr}
{ It is the Ems handle - a free entry in EmsFreeList cannot be > 64k}
end;
function VmmEmsFreeList.SizeToEndPtr(OrgPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given OrgPtr and block size, return new entry's EndPtr}
begin
{Assume BlkSize validity - entries cannot be greater than 64k}
Inc(VmmPtrRec(OrgPtr).Ofs, Word(BlkSize));
SizeToEndPtr := OrgPtr;
{The segment part is assumed to be the same for EndPtr and OrgPtr}
{ It is the Ems handle}
end;
function VmmEmsFreeList.SizeToOrgPtr(EndPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
begin
{Assume BlkSize validity - entries cannot be greater than 64k}
Dec(VmmPtrRec(EndPtr).Ofs, Word(BlkSize));
SizeToOrgPtr :=EndPtr;
{The segment part is assumed to be the same for EndPtr and OrgPtr}
{ It is the Ems handle}
end;
function VmmEmsFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
{-Return true if pointers can be merged to form a new freelist entry}
begin
PtrIsEqual := P1 = P2; {Segment (handle) and offset must be the same}
end;
{---------------------------------------------------------------------}
function VmmDskFreeList.GetFreeEntrySize(Index : Word) : LongInt;
{-Return size of a free block}
var
F : FreeRecord;
Offsets : array [1..2] of LongInt absolute F;
begin
GetElem(Index, F);
if GetStatus = 0 then
GetFreeEntrySize := Offsets[2] - Offsets[1]
else
GetFreeEntrySize := 0;
end;
function VmmDskFreeList.SizeToEndPtr(OrgPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given OrgPtr and block size, return new entry's EndPtr}
var
BlockOrg : LongInt absolute OrgPtr;
begin
SizeToEndPtr := Pointer(BlockOrg + BlkSize);
end;
function VmmDskFreeList.SizeToOrgPtr(EndPtr : Pointer;
BlkSize : LongInt) : Pointer;
{-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
var
BlockEnd : LongInt absolute EndPtr;
begin
SizeToOrgPtr := Pointer(BlockEnd - BlkSize);
end;
function VmmDskFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
{-Return true if pointers can be merged to form a new freelist entry}
begin
PtrIsEqual := P1 = P2; {LongInt(P1) = LongInt(P2)}
end;